home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 008 / bonus.arc / BIGCLOCK.LSP < prev    next >
Encoding:
Text File  |  1986-06-25  |  3.9 KB  |  141 lines
  1.  
  2. ;    The Clock
  3.  
  4. ;    A refined analogue clock for AutoCAD
  5.  
  6. ;    Designed and implemented in January 1986 by Kelvin R. Throop
  7.  
  8. ;    Enter ^C to terminate
  9.  
  10. (expand 100)
  11.  
  12. (setq f '(3 791 893 4 789 913 4 783 933 4 773 951 4 760 966 4 745 979 4
  13.       727 989 4 708 994 4 688 996 4 667 994 4 648 989 4 630 979 4
  14.       615 966 4 602 951 4 592 933 4 586 913 4 584 893 4 586 873 4
  15.       592 854 4 602 836 4 615 820 4 630 808 4 648 798 4 667 792 4
  16.       688 790 4 708 792 4 727 798 4 745 808 4 760 820 4 773 836 4
  17.       783 854 4 789 873 4 791 893 4 771 893 3 760 935 4 777 945 3
  18.       729 966 4 739 983 3 688 977 4 688 996 3 636 983 4 646 966 3
  19.       615 935 4 598 945 3 604 893 4 584 893 3 598 842 4 615 851 3
  20.       646 821 4 636 804 3 688 809 4 688 790 3 739 804 4 729 821 3
  21.       760 851 4 777 842 3 791 756 4 791 241 4 584 241 4 550 206 4
  22.       550 137 4 825 137 4 825 206 4 791 241 3 825 206 4 550 206 3
  23.       584 241 4 584 756 3 550 756 4 550 1031 4 825 1031 4 825 756 4
  24.       550 756 3 516 996 4 688 1168 4 859 996 3 773 1048 4 602 1048
  25.       4 688 1134 4 773 1048))
  26.  
  27. (setq mname '("January" "February" "March" "April" "May" "June"
  28.           "July" "August" "September" "October" "November" "December"))
  29.  
  30. (setq dname '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday"
  31.           "Saturday"))
  32.  
  33. (defun date (td / j y d m s)
  34.     (setq j (fix td))
  35.     (setq j (- j 1721119.0))
  36.     (setq y (fix (/ (1- (* 4 j)) 146097.0)))
  37.     (setq j (- (* j 4.0) 1.0 (* 146097.0 y)))
  38.     (setq d (fix (/ j 4.0)))
  39.     (setq j (fix (/ (+ (* 4.0 d) 3.0) 1461.0)))
  40.     (setq d (- (+ (* 4.0 d) 3.0) (* 1461.0 j)))
  41.     (setq d (fix (/ (+ d 4.0) 4.0)))
  42.     (setq m (fix (/ (- (* 5.0 d) 3) 153.0)))
  43.     (setq d (- (* 5.0 d) 3.0 (* 153.0 m)))
  44.     (setq d (fix (/ (+ d 5.0) 5.0)))
  45.     (setq y (+ (* 100.0 y) j))
  46.     (if (< m 10.0)
  47.        (setq m (+ m 3))
  48.        (progn
  49.           (setq m (- m 9))
  50.           (setq y (1+ y))
  51.        )
  52.     )
  53.     (strcat (nth (fix (rem (1+ td) 7)) dname) ", "
  54.        (nth (1- m) mname) " " (rtos d 2 0) ", "
  55.        (rtos y 2 0))
  56. )
  57.  
  58. (defun *ERROR* (s)
  59.     (redraw)
  60.     (grtext)
  61. )
  62.  
  63. (defun c:clock (/ a gsf m n x y mhl hhl dtr a270 a9 op fp np tp pl
  64.           pend phh lx ly lh r i hlb pi2 pio2 time ti hh mm nh lh
  65.           lm nm)
  66.     (grclear)
  67.     (grtext -2 "")
  68.     (setq i -1 hlb 0)
  69.     (while (< i 20)
  70.        (grtext (setq i (1+ i)) "")
  71.     )
  72.     (setq n (/ (length f) 3)
  73.           gsf (/ 1200.0 (getvar "viewsize"))
  74.           i 0
  75.     )
  76.     (repeat n
  77.        (setq m (nth i f)
  78.          x (/ (nth (1+ i) f) gsf)
  79.          y (/ (nth (+ 2 i) f) gsf)
  80.          i (+ 3 i)
  81.        )
  82.        (if (= m 3)
  83.           (setq lx x ly y)
  84.           (grdraw (list lx ly) (list (setq lx x) (setq ly y)) 7)
  85.        )
  86.     )
  87.  
  88.     (setq r 0.0)
  89.     (setq fp (list (/ 688 gsf) (/ 722 gsf)))
  90.     (setq op (list (/ 688 gsf) (/ 893 gsf)))
  91.     (setq pl (/ (- 722 309) gsf))
  92.     (setq mhl (/ 90 gsf))
  93.     (setq hhl (/ 60 gsf))
  94.     (setq dtr (/ pi 180.0))
  95.     (setq a270 (* 270.0 dtr))
  96.     (setq a9 (* 9 dtr))
  97.     (setq pend nil)
  98.     (while (<= r (* 2 pi))
  99.        (setq pend (cons (polar fp (+ a270 (* a9 (sin r))) pl) pend))
  100.        (setq r (+ r 0.25))
  101.     )
  102.  
  103.     (grdraw fp (setq tp (car pend)) -1)
  104.     (setq j (1+ (setq uc 10)))
  105.     (setq lh op lm op)
  106.     (setq pi2 (* 2 pi)
  107.           pio2 (/ pi 2)
  108.     )
  109.     (while t
  110.        (grtext (setq hlb (rem (1+ hlb) 20)) "" 1)
  111.        (if (> (setq j (1+ j)) uc)
  112.           (progn
  113.          (setq j 0)
  114.          (setq time (getvar "date"))
  115.          (grtext -1 (date time))
  116.          (setq ti (setq time (* 86400.0 (- time (fix time)))))
  117.          (setq hh (fix (/ time 3600.0)))
  118.          (setq time (- time (* hh 3600.0)))
  119.          (setq mm (fix (/ time 60.0)))
  120.          (grtext -2 (strcat (itoa (if (=
  121.            (setq phh (rem hh 12)) 0) 12 phh)) ":"
  122.            (if (< mm 10) "0" "")
  123.            (itoa mm) " " (if (< hh 13) "AM" "PM")))
  124.          (grdraw op (setq nh (polar op (- pio2 (* pi2 (/ ti 43200.0)))
  125.                  hhl)) -1)
  126.          (grdraw op (setq nm (polar op (- pio2 (* pi2 (/ time 3600.0)))
  127.                  mhl)) -1)
  128.          (grdraw op lh -1)
  129.          (grdraw op lm -1)
  130.          (setq lh nh lm nm)
  131.           )
  132.        )
  133.        (setq i 0)
  134.        (while (setq np (nth (setq i (1+ i)) pend))
  135.           (grdraw fp np -1)
  136.           (grdraw fp tp -1)
  137.           (setq tp np)
  138.        )
  139.     )
  140. )
  141.